home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / LIBRARY / PBLIB1 / PROGS / TP.PAS < prev    next >
Pascal/Delphi Source File  |  1994-05-03  |  19KB  |  616 lines
  1. PROGRAM TP;
  2.  
  3. {$M 20000,0,25000}
  4.  
  5. Uses DOS, CRT, PbCRT, PbMISC, PbDATA, PbPARMS;
  6.  
  7. {
  8. Description : Turbo Development shell
  9.  
  10. Author      : Howard Richoux
  11. Date        : 12/19/93
  12. Last revised: 12/21/93 hnr minor fixes    Works well!
  13.               12/22/93 1.14 hnr cleaned up CLEANUP
  14.               12/23/93 1.15 hnr added DOC and CFG cmds
  15.               12/24/93 1.16 hnr added Find cmd
  16.               2/13/93  1.20 hnr added PLAY, RELEASE=, MAINONLY=
  17.               2/13/93  1.21 hnr added BACKUP and PUT
  18.               *** need switchable tp.cfg ***
  19.               2/17/94  1.25 hnr added COMPILER=
  20.               2/18/94  1.26 hnr new libraries
  21. Application : IBM PC and compatibles, done in Turbo Pascal 7.0
  22. Status      : Placed in the Public Domain by HNR Software 1/29/94
  23. Published in: none
  24.  
  25.  
  26. Parameters            Use                            Default
  27. PROMPT=xxxx           CRT prompt string              '*'
  28. MAIN=<fname>          main Pascal program            ''
  29. FILE1=<fname>         support unit                   ''
  30. ...
  31. FILE5=<fname>         support unit                   ''
  32. EDITOR=<exename>      designates edit program        '\hnrutil\ted.exe'
  33. COMPILER=<exename>    designates compiler program    '\bp\bin\tpc.exe'
  34. COMPswitch=xxx        compiler switch option         ''
  35. PROGPATH=<dir>        where to get 'main'            '\hnrprog'
  36. UNITPATH=<dir>        where to get 'filen'           '\hnrstuf'
  37. EXEPATH=<dir>         where to put exe               '\hnrutil'
  38. }
  39.  
  40.  
  41.  
  42. const debug = 0;
  43.  
  44. var outfile     : string;
  45.     maincolor   : integer;
  46.     statuscolor : integer;
  47. var prompt      : string[20];
  48.  
  49. const files_max = 5;
  50. type  files_array = array[1..files_max] of string[8];
  51.  
  52. var main      : string[8];
  53.     files     : files_array;
  54.     progpath  : string[60];
  55.     unitpath  : string[60];
  56.     exepath   : string[60];
  57.     tpcfgpath : string[60];
  58.     logfile   : string[60];
  59.     editor    : string[60];
  60.     compiler  : string[60];
  61.     compswitch: string[60];
  62.     cfgfile   : string[60];
  63.  
  64. var   InputType : integer;
  65.       mapflag   : boolean;
  66.       UnitsOnlyFlag : boolean;  { for test-type programs - no release }
  67.       MainOnlyFlag  : boolean;  { for Utility programs where units were used for testin}
  68.       ReleaseFlag   : boolean;  { overall control }
  69.  
  70. const typInputCRT = 1;
  71. const typInputFIL = 2;
  72.  
  73. {*****************************************************************}
  74.  
  75. Procedure WorkWindowx;
  76.      begin
  77.      CRT.window(1,1,80,22);
  78.      gotoxy(1,22);
  79.      end;
  80.  
  81.  
  82. Procedure StatusWindowx;
  83.      begin
  84.      CRT.gotoxy(1,22);
  85.      writeln('');
  86.      writeln('');
  87.      CRT.window(1,23,80,24);
  88.      gotoxy(1,22);
  89.      end;
  90.  
  91.  
  92. Function HiLite(fname : string; ln : integer):string;
  93. var fn,s : string;
  94.      begin
  95.      s := fname;
  96.      fn := fname;
  97.      forceext(fn,'pas');
  98.      if fileexists(fn) then
  99.           begin
  100.           s := leftstr(UpCaseStr(fname),ln);
  101.           if filedate(fname,'tpu') > filedate(fname,'pas') then
  102.               s := '*' + s;
  103.           end
  104.      else s := leftstr(DnCaseStr(fname),ln);
  105.      HiLite := s;
  106.      end;
  107.  
  108.  
  109. Procedure UpdateStatusLine;
  110. var x,y,i : integer;
  111.      begin
  112.      x := wherex; y := wherey;
  113.      if y > 22 then for i := 23 to y do writeln('');
  114.      CRT.TextColor(statuscolor);
  115.      gotoxy(1,24);write(conststr(' ',79));
  116.      gotoxy(1,25);
  117.      write(pProgID,': ',HiLite(MAIN,8));
  118.      for i := 1 to files_max do
  119.           begin
  120.           write(' ',i:1,'-',HiLite(files[i],8));
  121.           end;
  122.      CRT.clreol;
  123.      gotoxy(1,23);
  124.      CRT.TextColor(maincolor);
  125.      end;
  126.  
  127.  
  128. Procedure ClearStatusLine;
  129. var x,y,i : integer;
  130.      begin
  131.      x := wherex; y := wherey;
  132.      gotoxy(1,25);write(conststr(' ',79));
  133.      gotoxy(1,24);
  134.      gotoxy(1,23);
  135.      end;
  136.  
  137.  
  138. Procedure ExecCmd(s : string);   {[MISC] ExecuteCommand too long }
  139.      begin
  140.      writeln(s);
  141.      ExecuteCommand(s);
  142.      end;
  143.  
  144.  
  145. Function DecodeFN(s : string) : string;
  146. var i : integer;
  147.      begin
  148.      DecodeFN := '';
  149.      if length(s) =  1  then DecodeFN := main
  150.      else begin
  151.           for i := 1 to files_max do
  152.                begin
  153.                if s[2] = integerstr(i,1) then DecodeFN := files[i];
  154.                end;
  155.           end;
  156.      end;
  157.  
  158.  
  159. Procedure ShowSettings;
  160.      begin
  161.      writeln('TP     MAIN: ',main);
  162.      writeln('   ProgPath: ',leftstr(progpath,30));
  163.      writeln('   UnitPath: ',leftstr(unitpath,30));
  164.      writeln('');
  165.      end;
  166.  
  167.  
  168. Procedure CopyfileIfNecessary(fn1,fn2 : string);
  169. var ok : boolean;
  170.      begin
  171.      ok := true;
  172.      if not fileexists(fn1) then exit;
  173.      if not EquivalentFile(fn1,fn2) then
  174.           begin
  175.           if fileexists(fn2) and (filedate(fn2,'') > filedate(fn1,'')) then
  176.                begin
  177.                writeln(FmtFileInfo(fn1,''));
  178.                writeln(FmtFileInfo(fn2,''));
  179.                ok := CheckYesNo(fn2+' is NEWER - replace? ','n');
  180.                if ok then ok := CheckYesNo('Are you SURE? ','n');
  181.                end;
  182.         {  writeln('COPYING '+fn1+' '+fn2);}
  183.           if ok then ExecCmd('copy '+fn1+' '+fn2);
  184.           end;
  185.      end;
  186.  
  187.  
  188. Procedure DoBAT(fname : string);
  189. var fn : string;
  190.      begin
  191.      if fname = '' then exit;
  192.      fn := fname;
  193.      forceext(fn,'bat');
  194.      if fileexists(fn) then
  195.           ExecCmd(fn)
  196.      else writeln('Batch file does not exist [',fn,']');
  197.      end;
  198.  
  199.  
  200. Procedure DoGetFile(s,ext : string);
  201. var fn,fn1 : string;
  202.      begin
  203.      fn := DecodeFN(s);
  204.      if fn = '' then exit;
  205.      ForceExt(fn,ext);
  206.      if length(s) = 1 then
  207.           fn1 := addbackslash(progpath)+fn
  208.      else fn1 := addbackslash(unitpath)+fn;
  209.      CopyFileIfNecessary(fn1,fn);
  210.      end;
  211.  
  212.  
  213. Procedure DoFindFiles(s,ext : string);
  214. var fn,fn1 : string;
  215.      begin
  216.      fn := DecodeFN(s);
  217.      if fn = '' then exit;
  218.      ForceExt(fn,ext);
  219.      ExecCmd('find '+fn);
  220.      end;
  221.  
  222.  
  223. Procedure DoEditor(s,ext : string);
  224. var fn : string;
  225.      begin
  226.      if leftstr(s,3) = 'TED' then
  227.           begin
  228.           fn := s;
  229.           delete(fn,1,4);
  230.           end
  231.      else if leftstr(s,4) = 'EDIT' then
  232.           begin
  233.           fn := s;
  234.           delete(fn,1,5);
  235.           end
  236.      else fn := DecodeFN(s);
  237.      if fn = '' then
  238.           begin
  239.           writeln('No file specified. [',s,']');
  240.           exit;
  241.           end;
  242.      if ext <> '' then ForceExt(fn,ext);
  243.      ExecCmd(Editor+' '+fn);
  244.      end;
  245.  
  246.  
  247.  
  248. Procedure DoPrintFile(str,ext : string;intflag : boolean);
  249. var fn,s : string;
  250.      begin
  251.      s := '';
  252.      fn := DecodeFN(str);
  253.      writeln(s,' [',fn,']');
  254.      if fn = '' then exit;
  255.      if intflag then
  256.           begin
  257.           s := ' INTERFACE=YES';
  258.           if length(s) = 1 then
  259.                begin
  260.                writeln('Unable to print Interface ONLY on a Program - ',fn);
  261.                exit;
  262.                end;
  263.           end;
  264.      if ext <> '' then ForceExt(fn,ext);
  265.      ExecCmd('TLISTER '+fn+s);
  266.      end;
  267.  
  268.  
  269. Procedure DoCompile(s,ext : string);
  270. var fn : string;
  271.      begin
  272.      fn := DecodeFN(s);
  273.      if fn = '' then exit;
  274.      forceext(fn,'tpu');
  275.      erasefile(fn);
  276.      forceext(fn,'tpp');
  277.      erasefile(fn);
  278.      forceext(fn,'exe');
  279.      erasefile(fn);
  280.      forceext(fn,'pas');
  281.      if fileexists(fn) then
  282.           begin
  283.           if mapflag then ExecCmd(compiler+' '+compswitch+' /GP '+fn)
  284.           else ExecCmd(compiler+' '+compswitch+' '+fn);
  285.           end;
  286.      end;
  287.  
  288.  
  289. Procedure CleanUpOneFile(root,ext,destpath,prompt : string;var moved : boolean);
  290.        { Returns file to master library if changed }
  291. var fn1,fn2  : string;
  292.     ok       : boolean;
  293.      begin
  294.      moved := false;
  295.      { fn1 Master copy, fn2 New work }
  296.      fn1 := root; forceext(fn1,ext); fn1 := addbackslash(destpath)+fn1; {MASTER}
  297.      fn2 := root; forceext(fn2,ext);   {NEW file}
  298.      if filedate(fn2,'') > filedate(fn1,'') then
  299.           begin
  300.           ok := CheckYesNo('Need to update MASTER -'+prompt+'- File: '+
  301.                             fn1+' OK?','N');
  302.           CopyFileIfNecessary(fn2,fn1);
  303.           if EquivalentFile(fn1,fn2) then   {makes sure copy went OK}
  304.                begin
  305.                moved := true;
  306.                writeln('Erasing ',fn2);
  307.                EraseFile(fn2);
  308.                end;
  309.           end
  310.      else begin  { no updating needed }
  311.           if fileexists(fn2) then writeln('Erasing ',fn2);
  312.           EraseFile(fn2);
  313.           end;
  314.      end;
  315.  
  316.  
  317. Procedure CleanUpFiles;
  318.        { Done on Completion }
  319. var s,cmd,fn1,fn2 : string;
  320. var i         : integer;
  321.     ok,moved  : boolean;
  322.      begin
  323.      if not releaseflag then
  324.           begin
  325.           writeln('RELEASE is set to NO, Files will NOT be moved.');
  326.           ExecCmd('Erase *.bak');
  327.           ExecCmd('DDIR');
  328.           exit;
  329.           end;
  330.      if not unitsonlyflag then
  331.           begin
  332.           CleanUpOneFile(main,'pas',progpath,'MAIN Source',moved);
  333.           CleanUpOneFile(main,'exe',exepath, 'MAIN EXE',moved);
  334.  
  335.           CleanUpOneFile(main,'doc',progpath,'Documentation',moved);
  336.           if moved then   { Copy the Master DOC file to the EXE path }
  337.                begin
  338.                fn1 := main; forceext(fn1,'doc');
  339.                fn2 := main; forceext(fn2,'doc');
  340.                fn1 := addbackslash(exepath)+fn1;   {fn1 - exe path }
  341.                fn2 := addbackslash(progpath)+fn2;  {fn2 - MASTER}
  342.                CopyFileIfNecessary(fn2,fn1);
  343.                end;
  344.           end
  345.      else begin
  346.           writeln('UNITSONLY=YES, MAIN not moved.');
  347.           end;
  348.  
  349.      if not mainonlyflag then
  350.           begin
  351.           { SUPPORT UNITS - fn1 Old Master copy, fn2 New work }
  352.           for i := 1 to files_max do
  353.                begin
  354.                if files[i] <> '' then
  355.                     begin
  356.                     CleanUpOneFile(files[i],'pas',unitpath,'UNIT Source',moved);
  357.                     fn2 := files[i]; forceext(fn2,'pas');
  358.                     if moved then
  359.                          begin
  360.                          writeln('*** Remember to RE-BUILD UNIT Library (MAKEPUB) ***');
  361.                          end;
  362.                     fn2 := files[i]; forceext(fn2,'tpu'); {local TPU file}
  363.                     forceext(fn2,'tpu');  { erasing TPU file }
  364.                     if fileexists(fn2) then
  365.                          begin
  366.                          writeln('Erasing ',fn2);
  367.                          EraseFile(fn2);
  368.                          end;
  369.                     forceext(fn2,'tpp');  { erasing TPP file }
  370.                     if fileexists(fn2) then
  371.                          begin
  372.                          writeln('Erasing ',fn2);
  373.                          EraseFile(fn2);
  374.                          end;
  375.                     end;
  376.                end;
  377.           end
  378.      else begin
  379.           writeln('MAINONLY=YES, UNITS not moved.');
  380.           end;
  381.      ExecCmd('Erase *.bak');
  382.      ExecCmd('DDIR');
  383.      end;
  384.  
  385.  
  386.  
  387. {PAGE}
  388. Procedure GetCRTInput(prompt : string; var s,cmd : string);
  389.      begin
  390.      write(prompt);CRT.Clreol;
  391.      GetKeyInput(s,cmd);
  392.      writeln('');
  393.      end;
  394.  
  395.  
  396.  
  397. Procedure ProcessInput(var str,cmd : string);
  398. var s,s1 : string;
  399.      begin
  400.      s := UpCaseStr(str);
  401.      if (debug>0) then writeln('     str=[',s,']   cmd[',cmd,']');
  402.  
  403.      writeln('');
  404.      if      s = 'CFG'  then    DoEditor(main,'cfg')
  405.      else if s = 'BACKUP'  then begin
  406.                            ExecCmd('ZIP');  {copy/pack this DIR}
  407.                            GetDir(0,s1);
  408.                            s1 := dirtag(s1);
  409.                            ExecCmd('PUT '+s1);  {Backup to floppy}
  410.                            end
  411.      else if s = 'CLEANUP' then CleanUpFiles
  412.      else if s = 'DIR'  then    ExecCmd('ddir')
  413.      else if leftstr(s,3) = 'TED'   then DoEditor(s,'')
  414.      else if leftstr(s,4) = 'EDIT'  then DoEditor(s,'')
  415.      else if s = 'C'    then  begin  { fix this later }
  416.                               DoCompile('C5','pas');
  417.                               DoCompile('C4','pas');
  418.                               DoCompile('C3','pas');
  419.                               DoCompile('C2','pas');
  420.                               DoCompile('C1','pas');
  421.                               DoCompile('C','pas');
  422.                               end
  423.      else if s = 'CLS'  then  begin
  424.                               CRT.clrscr;
  425.                               gotoxy(1,3);
  426.                               end
  427.      else if s = 'CFG'  then  DoEditor('E','CFG')
  428.      else if s = 'DOC'  then  DoEditor('E','DOC')
  429.      else if s = 'HELP' then  ShowDOCFile
  430.      else if s = 'G'    then  begin
  431.                               if not unitsonlyflag then
  432.                                    begin
  433.                                    DoGetFile('G','pas');
  434.                                    DoGetFile('G','doc');
  435.                                    end;
  436.                               DoGetFile('G1','pas');
  437.                               DoGetFile('G2','pas');
  438.                               DoGetFile('G3','pas');
  439.                               DoGetFile('G4','pas');
  440.                               DoGetFile('G5','pas');
  441.                               end
  442.      else if s = 'L'     then ShowSettings
  443.      else if s = 'MAP'   then EXECCmd('TMAP *.map 3 p')
  444.      else if s = 'MAPON' then mapflag := true
  445.      else if s = 'MAPOFF' then begin
  446.                               mapflag := false;
  447.                               ExecCmd('Erase *.map');
  448.                               end
  449.      else if s = 'PLAY' then  ExecCmd('PLAY') {Play a CD}
  450.      else if s = 'PUT'  then  begin
  451.                               ExecCmd('PUT');  {Backup to floppy}
  452.                               end
  453.      else if s = 'Q'    then  cmd := '?EXIT'
  454.      else if s = 'T'    then  DoBAT('T.BAT')
  455.      else if s = 'T1'   then  DoBAT('T1.BAT')
  456.      else if s = 'T2'   then  DoBAT('T2.BAT')
  457.      else if s = 'T3'   then  DoBAT('T3.BAT')
  458.      else if s = 'T4'   then  DoBAT('T4.BAT')
  459.      else if s = 'T5'   then  DoBAT('T5.BAT')
  460.      else if s = 'X'    then  cmd := '?EXIT'
  461.      else if s = 'ZIP'  then  ExecCmd('ZIP')
  462.      else if s[1] = 'C' then  DoCompile(s,'pas')
  463.      else if s[1] = 'E' then  DoEditor(s,'pas')
  464.      else if s[1] = 'F' then  DoFindFiles(s,'pas')
  465.      else if s[1] = 'G' then  DoGetFile(s,'pas')
  466.      else if s[1] = 'I' then  DoPrintFile(s,'pas',true)
  467.      else if s[1] = 'P' then  DoPrintFile(s,'pas',false)
  468.      else begin
  469.           writeln('');
  470.           writeln('? [',str,']');
  471.           end;
  472.      end;
  473.  
  474.  
  475. Procedure MainInputLoop;
  476. var str,cmd : string;
  477. var i     : integer;
  478.      begin
  479.      writeln('');
  480.      UpdateStatusLine;
  481.      i := 0; str := ''; cmd := '?STRING';
  482.      while (cmd <> '?EXIT') and (cmd <> '?ESCAPE') do
  483.           begin
  484.           UpdateStatusLine;
  485.           case InputType of
  486.                  typInputCRT : GetCRTInput(prompt,str,cmd);
  487.                  else          begin
  488.                                writeln('MAIN Input loop - bad input type [',
  489.                                         InputType,']');
  490.                                cmd := '?ESCAPE';
  491.                                end;
  492.                  end;
  493.           writeln('');
  494.           ClearStatusLine;
  495.           if      cmd = '?FKEY1' then ShowDOCFile
  496.           else if cmd = '?FKEY10' then cmd := '?EXIT'
  497.           else ProcessInput(str,cmd);
  498.           {inc(i); if i > 500 then cmd := '?ESCAPE';}   {safety valve}
  499.           end;
  500.      end;
  501.  
  502.  
  503. Procedure PrepareFiles;
  504.        { Done on Startup }
  505. var s,cmd,fn1,fn2 : string;
  506. var i : integer;
  507.      begin
  508.      fn1 := main; forceext(fn1,'pas'); fn1 := addbackslash(progpath)+fn1;
  509.      fn2 := main; forceext(fn2,'pas');
  510.      CopyfileIfNecessary(fn1,fn2);
  511.  
  512.      for i := 1 to files_max do
  513.           begin
  514.           if files[i] <> '' then
  515.                begin
  516.                fn1 := files[i];
  517.                forceext(fn1,'pas');
  518.                fn1 := addbackslash(unitpath)+fn1;
  519.                fn2 := files[i];
  520.                forceext(fn2,'pas');
  521.                CopyfileIfNecessary(fn1,fn2);
  522.                end;
  523.           end;
  524.      cmd := '';
  525.      s := 'DIR';  ProcessInput(s,cmd);
  526.      end;
  527.  
  528.  
  529. Procedure GetCFGFile;
  530. var s,fn : string;
  531.      begin
  532.      tpcfgpath := '';
  533.      s := '';
  534.      if paramcount > 0 then s := paramstr(1);
  535.      if s[1] = '@' then
  536.           begin
  537.           delete(s,1,1);
  538.           fn := s;
  539.           if fileexists(fn) then
  540.                begin
  541.                copyfileifnecessary(fn,'tp.cfg');
  542.                end;
  543.           end;
  544.      end;
  545.  
  546.  
  547. Procedure Init;
  548. var s : string;
  549.     begin
  550.     InputType := typInputCRT;
  551.     AddParm(1,'MAIN','');
  552.     AddParm(1,'FILE1','');
  553.     AddParm(1,'FILE2','');
  554.     AddParm(1,'FILE3','');
  555.     AddParm(1,'FILE4','');
  556.     AddParm(1,'FILE5','');
  557.     AddParm(1,'EDITOR','C:\UTIL\TED.EXE');
  558.     AddParm(1,'COMPILER','C:\BP\BIN\TPC.EXE');
  559.     AddParm(1,'COMPSWITCH','');
  560.     AddParm(1,'PROGPATH','C:\HNRPROG\');
  561.     AddParm(1,'UNITPATH','C:\HNRSTUF\');
  562.     AddParm(1,'EXEPATH','C:\HNRUTIL\');
  563.     AddParm(1,'LOGFILE','\HNRUTIL\TP.LOG');
  564.     AddParm(1,'MAP','NO');
  565.     AddParm(1,'RELEASE','NO');
  566.     AddParm(1,'UNITSONLY','NO');
  567.     AddParm(1,'MAINONLY','NO');
  568.     StandardPvarsInit;
  569.     main  := GetParmStr('MAIN');
  570.     if files_max >= 1 then files[1] := GetParmStr('FILE1');
  571.     if files_max >= 2 then files[2] := GetParmStr('FILE2');
  572.     if files_max >= 3 then files[3] := GetParmStr('FILE3');
  573.     if files_max >= 4 then files[4] := GetParmStr('FILE4');
  574.     if files_max >= 5 then files[5] := GetParmStr('FILE5');
  575.     editor   := GetParmStr('EDITOR');
  576.     compiler := GetParmStr('COMPILER');
  577.     compswitch := GetParmStr('COMPSWITCH');
  578.     progpath := GetParmStr('PROGPATH');
  579.     unitpath := GetParmStr('UNITPATH');
  580.     exepath  := GetParmStr('EXEPATH');
  581.     logfile  := GetParmStr('LOGFILE');
  582.     mapflag  := CheckOK('MAP');
  583.     releaseflag   := CheckOK('RELEASE');
  584.     unitsonlyflag := CheckOK('UNITSONLY');
  585.     mainonlyflag  := CheckOK('MAINONLY');
  586.     prompt   := 'TP>';
  587.     end;
  588.  
  589.  
  590.  
  591. (*  Main program *)
  592.      BEGIN
  593.      maincolor   := lightgray;
  594.      statuscolor := yellow;
  595.      CRT.TextColor(maincolor);
  596.      pProgID := 'TP 1.26';
  597.  
  598.      cfgfile := FileRootStr(paramstr(0)) + '.cfg';
  599.      if UpCaseStr(paramstr(1)) = 'HELP' then ShowDocFile
  600.      else if (not fileExists(cfgfile)) or (paramcount > 0) then
  601.           begin
  602.           GetCFGFile;
  603.           Init;
  604.           if main <> '' then PrepareFiles
  605.           else writeln('No MAIN file specified');
  606.           end
  607.      else begin
  608.           Init;
  609.           if main <> '' then MainInputLoop
  610.           else writeln('No MAIN file specified');
  611.           end;
  612.      CRT.TextColor(maincolor);
  613.      end.
  614.  
  615.  
  616.